home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
007
/
simcode.arc
/
TOKEN.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1984-12-03
|
6KB
|
212 lines
{$symtab-,$linesize:131,$pagesize:86,$debug-,
$title:'TOKEN.PAS -- Tokenize the script files'}
{ COPYRIGHT @ 1982
Jim Holtman and Eric Holtman
35 Dogwood Trail
Randolph, NJ 07869
(201) 361-3395
}
module tokens;
var
i,j : integer;
buf : lstring(255);
str : lstring(255);
lineno [public] : integer;
charno [public] : integer;
line_inc : boolean;
back_stack : lstring(255);
back_ptr : integer;
comp_file_name [external] : lstring(20);
current_line : lstring(255);
value lineno := 0;
charno := 0;
line_inc := false;
back_ptr := 0;
function getbchar : integer;
begin
if (back_ptr > 0) then begin
getbchar := ord(back_stack[back_ptr]);
back_ptr := back_ptr - 1;
end
else getbchar := -1;
end;
procedure putbchar(ch : char)[public];
begin
back_ptr := back_ptr + 1;
back_stack[back_ptr] := ch;
end;
procedure putbstr(const s : lstring)[public];
var
i : integer;
begin
for i := ord(s.len) downto 1 do putbchar(s[i]);
end;
function getnextchar(var fd : text) : integer;
var
c : char;
i : integer;
s : lstring(255);
begin
i := getbchar;
if (i > -1) then begin
getnextchar := i;
charno := charno + 1;
return;
end;
if (eof(fd)) then begin
getnextchar := - 1;
return;
end;
lineno := lineno + 1;
charno := 0;
readln(fd, current_line);
putbchar(' ');
putbstr(current_line);
getnextchar := getnextchar(fd);
end;
procedure print_error(const mess : lstring;
back : integer) [public];
var
i,j : integer;
buf : lstring(255);
c : char;
begin
write(lineno:3,': ');
writeln(current_line);
write('-----');
j := 1;
for i := 1 to charno-1-back do begin
if (current_line[i] <> chr(9)) then begin
j := j + 1;
write('-') end
else begin
repeat
write('-');
j := j + 1;
until (j mod 8) = 1;
end;
end;
writeln('^ ',mess);
end;
function next_token(var d : lstring;
var fil : text) : integer [public];
var
i,j : integer;
state : integer;
s : char;
nc : integer;
st : integer;
typ : integer;
{$include:'token.h'}
begin
i := 0;
j := 0;
s := chr(0);
st := 1;
typ := 0;
nc := getnextchar(fil);
if (nc > -1) then begin
while ((chr(nc) = ' ') or (chr(nc) = chr(9))) do begin
nc := getnextchar(fil);
if (nc = -1) then break;
end;
end;
state := OUT_QUOTE;
if (nc > -1) then s := chr(nc);
while true do begin {writeln('parsing -',s,'- -',ord(s));]}
if (eof(fil) and (s = chr(0))) then begin
next_token := -1;
d.len := wrd(j);
return;
end
else if ( ((s = ' ') or (s = chr(9))) and (state = OUT_QUOTE)) then
begin
d.len := wrd(j);
if (d = 'if') then next_token := TOK_IF
else if (d = 'dial') then next_token := TOK_DIAL
else if (d = 'send') then next_token := TOK_SEND
else if (d = 'say') then next_token := TOK_SAY
else if (d = 'goto') then next_token := TOK_GOTO
else if (d = 'name') then next_token := TOK_NAME
else if (d = 'else') then next_token := TOK_ELSE
else if (d = 'quit') then next_token := TOK_QUIT
else if (d = 'gosub') then next_token := TOK_GOSUB
else if (d = 'return') then next_token := TOK_RETURN
else if (d = '{') then next_token := TOK_LBRACK
else if (d = '}') then next_token := TOK_RBRACK
else if (d = 'input') then next_token := TOK_INPUT
else if (d = 'settime') then next_token := TOK_SETTIME
else if (d = 'openlog') then next_token := TOK_OPENLOG
else if (d = 'closelog') then next_token := TOK_CLOSELOG
else if (d = 'toggle_tr') then next_token := TOK_TOGGLE_TR
else if (d = 'case') then next_token := TOK_CASE
else if (d = 'caseend') then next_token := TOK_CASEEND
else if (d = 'otherwise') then next_token := TOK_OTHERWISE
else if (d[j] = ':') then next_token := TOK_LABEL
else begin
writeln;
print_error('Warning: constants should have quotes',j);
next_token := TOK_STR;
writeln;
end;
return;
end
else if ( (s = '"') and (state = IN_QUOTE) ) then begin
nc := getnextchar(fil);
if (nc <> ord(':')) then begin
next_token := TOK_STR;
d.len := wrd(j);
putbchar(chr(nc));
return;
end
else begin
j := j + 1;
d[j] := chr(nc);
d.len := wrd(j);
next_token := TOK_LABEL;
return;
end;
end
else if (s = '"') then state := -1 * state
else if (s = '\') then begin
st := st + 1;
j := j + 1;
nc := getnextchar(fil);
if (nc = -1) then begin
next_token := -1;
d.len := wrd(j);
return;
end;
s := chr(nc);
d[j] := s;
end
else begin
j := j + 1;
d[j] := s;
end;
st := st + 1;
nc := getnextchar(fil);
if (nc > -1) then s := chr(nc)
else s := chr(0);
end;
end;
end.